Syntax10b.Scn.Fnt
Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
MODULE POPM;	(* RC 6.3.89 / 19.10.92, mmb 4.3.91 / 30.10.92 *)
(* Machine dependent constants needed before code generation *)
(* Host interface, IBM RS/6000 version *)
(* modifications HM: *)
(* 94-05-09 MaxPtr and MaxGPtr smaller *)
(* 94-05-24 Sysflag 1 for records => 68K alignment in records (MaxSysFlag = 1 instead of 0) *)
	IMPORT
		Texts, Oberon, Files, SYSTEM;
	CONST (* IBM RS/6000 *)
		(* basic type sizes *)
		ByteSize* = 1;	(* SYSTEM.BYTE *)
		CharSize* = 1;	(* CHAR *)
		BoolSize* = 1;	(* BOOLEAN *)
		SetSize* = 4;	(* SET *)
		SIntSize* = 1;	(* SHORTINT *)
		IntSize* = 2;	(* INTEGER *)
		LIntSize* = 4;	(* LONGINT *)
		RealSize* = 4;	(* REAL *)
		LRealSize* = 8;	(* LONGREAL *)
		ProcSize* = 8;	(* PROCEDURE type *)
		PointerSize* = 4;	(* POINTER type *)
		(* value of constant NIL *)
		nilval* = 0;
		(* target machine minimum values of basic types expressed in host machine format: *)
		MinSInt* = -80H;
		MinInt* = -8000H;
		MinLInt* =  80000000H;	(*-2147483648*)
		MinRealPat = 0FF7FFFFFH;	(* most  negative, 32-bit pattern *)
		MinLRealPatL = 0FFEFFFFFH;	(* most  negative, lower 32-bit pattern *)
		MinLRealPatH = 0FFFFFFFFH;	(* most  negative, higher 32-bit pattern *)
		(* target machine maximum values of basic types expressed in host machine format: *)
		MaxSInt* = 7FH;
		MaxInt* = 7FFFH;
		MaxLInt* = 7FFFFFFFH;	(*2147483647*)
		MaxSet* = 31;	(* must be >= 15, else the bootstraped compiler cannot run (IN-tests) *)
		MaxRealPat = 7F7FFFFFH;	(* most positive, 32-bit pattern *)
		MaxLRealPatL = 7FEFFFFFH;	(* most positive, lower 32-bit pattern *)
		MaxLRealPatH = 0FFFFFFFFH;		(* most positive, higher 32-bit pattern *)
		(* maximal index value for array declaration: *)
		MaxIndex* = MaxLInt;
		(* parametrization of numeric scanner: *)
		MaxHDig* = 8;	(* maximal hexadecimal longint length *)
		MaxRExp* = 38;	(* maximal real exponent *)
		MaxLExp* = 308;	(* maximal longreal exponent *)
		(* inclusive range of parameter of standard procedure HALT: *)
		MinHaltNr* = 20;
		MaxHaltNr* = 255;
		(* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG: *)
		MinRegNr* = 0;
		MaxRegNr* = 66;	(* 0..31: Rx or FPRx, depending on second operand, 32..66: control registers *)
		(* encoding: code = 32+reg
			MQ = 0; XER = 1; fromRTCU = 4; fromRTCL = 5; fromDEC = 6; LR = 8; CTR = 9;
			CR = 32; MSR = 33; FPSCR = 34;
			others are privileged
		(* maximal value of flag used to mark interface structures: *)
		MaxSysFlag* = 1;	(* IBM RS/6000: only 0 is valid, not used *)
		(* maximal condition value of parameter of SYSTEM.CC: *)
		MaxCC* = -1;	(* IBM RS/6000: not used *)
		(* initialization of linkadr field in ObjDesc, must be different from any valid link address: *)
		LANotAlloc* = -1;
		(* initialization of constant address, must be different from any valid constant address: *)
		ConstNotAlloc* = -1;	(* IBM RS/6000: only strings are allocated *)
		(* initialization of tdadr field in StrDesc, must be different from any valid address: *)
		TDAdrUndef* = -1;
		(* maximal number of cases in a case statement: *)
		MaxCases* = 128;
		(* maximal range of a case statement (higher label - lower label ~ jump table size): *)
		MaxCaseRange* = 512;
		(* maximal number of exit statements within a (nested) loop statement: *)
		MaxExit* = 16;
		(* whether hidden pointer fields have to be nevertheless exported: *)
		ExpHdPtrFld* = TRUE;
		HdPtrName* = "@ptr";
		(* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free): *)
		ExpHdProcFld* = FALSE;
		HdProcName* = "@proc";
		(* whether hidden bound procedures have to be nevertheless exported: *)
		ExpHdTProc* = FALSE;
		HdTProcName* = "@tproc";
		(* maximal number of hidden fields in an exported record: *)
		MaxHdFld* = 512;
		(* whether addresses of formal parameters are exported: *)
		ExpParAdr* = TRUE;
		(* whether addresses or entry numbers are exported for global variables: *)
		ExpVarAdr* = TRUE;
		(* maximal number of exported stuctures: *)
		MaxStruct* = 255;	(* must be < 256 *)
		(* maximal number of pointer fields in a record: *)
		MaxPtr* = (*16384*) 1024;
		(* maximal number of global pointers: *)
		MaxGPtr* = (*16384*) 1024;
		(* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used: *)
		NEWusingAdr* = FALSE;
		(* special character (< " ") returned by procedure Get, if end of text reached *)
		Eot* = 0X;
		(* version flag *)
		CeresVersion* = FALSE;
		MinReal*, MaxReal*: REAL;
		MinLReal*, MaxLReal*: LONGREAL;
		noerr*: BOOLEAN;	(* no error found until now *)
		curpos*, errpos*: LONGINT;	(* character and error position in source file *)
		breakpc*: LONGINT;	(* set by OPV.Init *)
	CONST
		SFext = ".Sym";
		SFtag = 0F7X;	(* symbol file tag *)
		OFext = ".Obj";
		OFtag = 0F8X;	(* object file tag *)
	TYPE
		FileName = ARRAY 32 OF CHAR;
		LRealPat: RECORD L, H: LONGINT END ;
		lastpos, pat: LONGINT;	(* last position error in source file *)
		inR: Texts.Reader;
		Log: Texts.Text;
		W: Texts.Writer;
		oldSF, newSF, ObjF, RefF: Files.Rider;
		oldSFile, newSFile, ObjFile, RefFile: Files.File;
		Path: FileName;
		now301: BOOLEAN;
	PROCEDURE FlipBits* (i: LONGINT): LONGINT;
		VAR s, d: SET;
	BEGIN
		IF CeresVersion THEN
			s := SYSTEM.VAL(SET, i); d := {}; i := 0;
			WHILE i < 32 DO IF i IN s THEN INCL(d, 31-i) END; INC(i) END;
			RETURN SYSTEM.VAL(LONGINT, d)
		ELSE
			RETURN i
		END
	END FlipBits;
	PROCEDURE FlipBytes (VAR b: ARRAY OF SYSTEM.BYTE);
		VAR i, j: INTEGER; h: SYSTEM.BYTE;
	BEGIN i := 0; j := SHORT(LEN(b))-1;
		WHILE i < j DO h := b[i]; b[i] := b[j]; b[j] := h; INC(i); DEC(j) END
	END FlipBytes;
	PROCEDURE Init* (source: Texts.Reader; log: Texts.Text);
	BEGIN inR := source; Log := log;
		noerr := TRUE; curpos := Texts.Pos(inR); errpos := curpos; lastpos := curpos-10; now301 := FALSE
	END Init;
	PROCEDURE Get* (VAR ch: CHAR);	(* read next character from source text, Eot if no more *)
	BEGIN Texts.Read(inR, ch); INC(curpos)
	END Get;
	PROCEDURE NewKey* (): LONGINT;
		VAR time, date: LONGINT;
	BEGIN Oberon.GetClock(time, date); RETURN (time MOD 20000H) * (date MOD 4000H)
	END NewKey;
	PROCEDURE MakeFileName (VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR);
		VAR i, j: INTEGER; ch: CHAR;
	BEGIN i := 0;
		LOOP ch := name[i];
			IF ch = 0X THEN EXIT END ;
			FName[i] := ch; INC(i);
		END ;
		j := 0;
		REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j)
		UNTIL ch = 0X
	END MakeFileName;
	(* ------------------------- Log Output ------------------------- *)
	PROCEDURE LogW* (ch: CHAR);
	BEGIN
		Texts.Write(W, ch); Texts.Append(Log, W.buf)
	END LogW;
	PROCEDURE LogWStr* (s: ARRAY OF CHAR);
	BEGIN
		Texts.WriteString(W, s); Texts.Append(Log, W.buf)
	END LogWStr;
	PROCEDURE LogWNum* (i, len: LONGINT);
	BEGIN
		Texts.WriteInt(W, i, len); Texts.Append(Log, W.buf)
	END LogWNum;
	PROCEDURE LogWHex (i: LONGINT);
	BEGIN
		Texts.WriteHex(W, i); Texts.Write(W, "H"); Texts.Append(Log, W.buf)
	END LogWHex;
	PROCEDURE LogWLn*;
	BEGIN
		Texts.WriteLn(W); Texts.Append(Log, W.buf)
	END LogWLn;
	PROCEDURE Mark* (n: INTEGER; pos: LONGINT);
	BEGIN
		IF n >= 0 THEN
			noerr := FALSE;
			IF (pos < lastpos) OR (lastpos + 9 < pos) THEN lastpos := pos;
				LogWLn; LogWStr("  pos"); LogWNum(pos, 6);
				IF n = 255 THEN LogWStr("  pc "); LogWHex(breakpc)
				ELSIF n = 254 THEN LogWStr("  pc not found")
				ELSE LogWStr("  err"); LogWNum(n, 4)
				END
			END
		ELSE
			LogWLn; LogWStr("  pos"); LogWNum(pos, 6); LogWStr("  warning"); LogWNum(-n, 4)
		END
	END Mark;
	PROCEDURE err* (n: INTEGER);
	BEGIN
		IF n = -10000 THEN now301 := TRUE; RETURN END;
		IF (n = -301) & now301 THEN RETURN END;
		Mark(n, errpos)
	END err;
	(* ------------------------- Read Symbol File ------------------------- *)
	PROCEDURE SymRCh* (VAR b: CHAR);
	BEGIN Files.Read(oldSF, b)
	END SymRCh;
	PROCEDURE SymRTag* (VAR k: INTEGER);
		VAR i: LONGINT;
	BEGIN Files.ReadNum(oldSF, i); k := SHORT(i)
	END SymRTag;
	PROCEDURE SymRInt* (VAR k: LONGINT);
	BEGIN Files.ReadNum(oldSF, k)
	END SymRInt;
	PROCEDURE SymRLInt* (VAR k: LONGINT);
	BEGIN Files.ReadNum(oldSF, k)
	END SymRLInt;
	PROCEDURE SymRSet* (VAR s: SET);
		VAR j: LONGINT;
	BEGIN Files.ReadNum(oldSF, j);
		IF CeresVersion THEN j := FlipBits(j) END;
		s := SYSTEM.VAL(SET, j)
	END SymRSet;
	PROCEDURE SymRReal* (VAR r: REAL);
	BEGIN Files.ReadReal(oldSF, r)
	END SymRReal;
	PROCEDURE SymRLReal* (VAR lr: LONGREAL);
	BEGIN Files.ReadLReal(oldSF, lr)
	END SymRLReal;
	PROCEDURE CloseOldSym*;
	(* called only if OldSym previously returned done = TRUE *)
	END CloseOldSym;
	PROCEDURE OldSym* (VAR modName: ARRAY OF CHAR; self: BOOLEAN; VAR done: BOOLEAN);
	(* open file in read mode *)
		VAR ch: CHAR; fileName: FileName;
	BEGIN MakeFileName(modName, fileName, SFext);
		oldSFile := Files.Old(fileName); done := oldSFile # NIL;
		IF done THEN
			Files.Set(oldSF, oldSFile, 0); SymRCh(ch);
			IF ch # SFtag THEN err(151);  (*not a symbol file*)
				CloseOldSym; done := FALSE
			END
		ELSIF ~self THEN err(152)   (*sym file not found*)
		END
	END OldSym;
	PROCEDURE eofSF* (): BOOLEAN;
	(* = TRUE if end of old file reached *)
	BEGIN RETURN oldSF.eof
	END eofSF;
	(* ------------------------- Write Symbol File ------------------------- *)
	PROCEDURE SymWCh* (ch: CHAR);
	BEGIN Files.Write(newSF, ch)
	END SymWCh;
	PROCEDURE SymWTag* (k: INTEGER);
	BEGIN Files.WriteNum(newSF, k)
	END SymWTag;
	PROCEDURE SymWInt* (i: LONGINT);
	BEGIN Files.WriteNum(newSF, i)
	END SymWInt;
	PROCEDURE SymWLInt* (k: LONGINT);
	BEGIN Files.WriteNum(newSF, k)
	END SymWLInt;
	PROCEDURE SymWSet* (s: SET);
	BEGIN
		IF CeresVersion THEN
			Files.WriteNum(newSF, FlipBits(SYSTEM.VAL(LONGINT, s)))
		ELSE
			Files.WriteNum(newSF, SYSTEM.VAL(LONGINT, s))
		END
	END SymWSet;
	PROCEDURE SymWReal* (r: REAL);
	BEGIN Files.WriteReal(newSF, r)
	END SymWReal;
	PROCEDURE SymWLReal* (lr: LONGREAL);
	BEGIN Files.WriteLReal(newSF, lr)
	END SymWLReal;
	PROCEDURE RegisterNewSym* (VAR modName: ARRAY OF CHAR);
	(* delete possibly already existing file with same name, register new created file *)
	BEGIN Files.Register(newSFile)
	END RegisterNewSym;
	PROCEDURE DeleteNewSym*;
	(* delete new created file, don't touch possibly already existing file with same name *)
	END DeleteNewSym;
	PROCEDURE NewSym* (VAR modName: ARRAY OF CHAR; VAR done: BOOLEAN);
	(* open new file in write mode, don't touch possibly already existing file with same name *)
		VAR fileName: FileName;
	BEGIN MakeFileName(modName, fileName, SFext);
		newSFile := Files.New(fileName); done := newSFile # NIL;
		IF done THEN Files.Set(newSF, newSFile, 0);
			SymWCh(SFtag)
		ELSE err(153)
		END
	END NewSym;
	PROCEDURE EqualSym* (VAR oldkey: LONGINT): BOOLEAN;
	(* compare old and new Symbol File, close old file, return TRUE if equal *)
		VAR ch0, ch1: CHAR; equal: BOOLEAN; newkey: LONGINT;
	BEGIN
		Files.Set(oldSF, oldSFile, 2); Files.ReadNum(oldSF, oldkey);
		Files.Set(newSF, newSFile, 2); Files.ReadNum(newSF, newkey);
		REPEAT Files.Read(oldSF, ch0); Files.Read(newSF, ch1)
		UNTIL (ch0 # ch1) OR newSF.eof;
		equal := oldSF.eof & newSF.eof; CloseOldSym;
		RETURN equal
	END EqualSym;
	(* ------------------------- Write Reference & Object Files ------------------------- *)
	PROCEDURE RefW* (ch: CHAR);
	BEGIN Files.Write(RefF, ch)
	END RefW;
	PROCEDURE RefWNum* (i: LONGINT);
	BEGIN Files.WriteNum(RefF, i)
	END RefWNum;
	PROCEDURE RefWBytes* (VAR bytes: ARRAY OF SYSTEM.BYTE; n: LONGINT);	(* MK *)
	BEGIN Files.WriteBytes(RefF, bytes, n)
	END RefWBytes;
	PROCEDURE RefPos* (): LONGINT; 		(* MK *)
	BEGIN RETURN Files.Pos(RefF)
	END RefPos;
	PROCEDURE ObjW* (ch: CHAR);
	BEGIN Files.Write(ObjF, ch)
	END ObjW;
	PROCEDURE ObjWInt* (i: INTEGER);
	BEGIN
		Files.WriteBytes(ObjF, i, 2)
	END ObjWInt;
	PROCEDURE ObjWLInt* (i: LONGINT);
	BEGIN
		Files.WriteBytes(ObjF, i, 4)
	END ObjWLInt;
	PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SYSTEM.BYTE; n: LONGINT);
	BEGIN Files.WriteBytes(ObjF, bytes, n)
	END ObjWBytes;
	PROCEDURE OpenRefObj* (VAR modName: ARRAY OF CHAR);
		VAR FName: ARRAY 32 OF CHAR;
	BEGIN
		RefFile := Files.New(""); Files.Set(RefF, RefFile, 0);
		MakeFileName(modName, FName, OFext);
		ObjFile := Files.New(FName);
		IF ObjFile # NIL THEN
			Files.Set(ObjF, ObjFile, 0);
			ObjW(OFtag); ObjW("6"); ObjWInt(0); ObjWInt(0)
		ELSE err(153)
		END
	END OpenRefObj;
	PROCEDURE CloseRefObj*;
		VAR refsize: LONGINT; ch: CHAR; ref: Files.Rider;
	BEGIN (*ref block*)
		refsize := Files.Length(RefFile); ObjW(8BX);
		Files.Set(ref, RefFile, 0); Files.Read(ref, ch);
		WHILE ~ref.eof DO ObjW(ch); Files.Read(ref, ch) END ;
		Files.Set(ObjF, ObjFile, 2); ObjWLInt(refsize); (*ObjWBytes(refsize, 4);*)
		Files.Register(ObjFile)
	END CloseRefObj;
BEGIN
	pat := MinRealPat; SYSTEM.MOVE(SYSTEM.ADR(pat), SYSTEM.ADR(MinReal), 4);	(*-3.40282346E38*)
	pat := MaxRealPat; SYSTEM.MOVE(SYSTEM.ADR(pat), SYSTEM.ADR(MaxReal), 4);	(*3.40282346E38*)
	LRealPat.L := MinLRealPatL; LRealPat.H := MinLRealPatH;
	SYSTEM.MOVE(SYSTEM.ADR(LRealPat), SYSTEM.ADR(MinLReal), 8);	(*-1.7976931348623157D308*)
	LRealPat.L := MaxLRealPatL; LRealPat.H := MaxLRealPatH;
	SYSTEM.MOVE(SYSTEM.ADR(LRealPat), SYSTEM.ADR(MaxLReal), 8);	(*1.7976931348623157D308*)
	Texts.OpenWriter(W); Log := Oberon.Log
END POPM.